home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / w3 / w3-xemac.el < prev    next >
Encoding:
Text File  |  1995-08-31  |  56.4 KB  |  1,659 lines
  1. ;;; w3-xemac.el,v --- XEmacs specific functions for emacs-w3
  2. ;; Author: wmperry
  3. ;; Created: 1995/03/09 20:35:12
  4. ;; Version: 1.27
  5. ;; Keywords: faces, help, mouse, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
  9. ;;;
  10. ;;; This file is part of GNU Emacs.
  11. ;;;
  12. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;;; it under the terms of the GNU General Public License as published by
  14. ;;; the Free Software Foundation; either version 2, or (at your option)
  15. ;;; any later version.
  16. ;;;
  17. ;;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;;; GNU General Public License for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License
  23. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  24. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;; Enhancements For XEmacs
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. (require 'xpm-button)
  31. (require 'xbm-button)
  32.  
  33. (defvar w3-allowed-image-types
  34.   (mapcar (function (lambda (x) (list (car x)))) w3-graphic-converter-alist))
  35.  
  36. (make-variable-buffer-local 'w3-links-menu)
  37.  
  38. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39. ;;; Spiffy new toolbar for XEmacs 19.12 only
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41. (defvar w3-links-menu nil "Menu for w3-mode in XEmacs.")
  42. (defvar w3-image-type-restriction nil)
  43. (defvar w3-image-size-restriction nil)
  44. (defvar w3-options-menu nil "The options menu for w3.")
  45. (defvar w3-toolbar-icon-directory nil "Where the toolbar icons for w3 are.")
  46. (defvar w3-toolbar-back-icon nil "Toolbar icon for back")
  47. (defvar w3-toolbar-forw-icon nil "Toolbar icon for forward")
  48. (defvar w3-toolbar-home-icon nil "Toolbar icon for home")
  49. (defvar w3-toolbar-reld-icon nil "Toolbar icon for reload")
  50. (defvar w3-toolbar-imag-icon nil "Toolbar icon for images")
  51. (defvar w3-toolbar-open-icon nil "Toolbar icon for open url")
  52. (defvar w3-toolbar-print-icon nil "Toolbar icon for printing")
  53. (defvar w3-toolbar-find-icon nil "Toolbar icon for find")
  54. (defvar w3-toolbar-stop-icon nil "Toolbar icon for stop")
  55. (defvar w3-toolbar-help-icon nil "Toolbar icon for help")
  56. (defvar w3-toolbar-hotl-icon nil "Toolbar icon for hotlist")
  57.  
  58. (defvar w3-link-toolbar-orientation 'bottom
  59.   "*Where to put the document specific toolbar.  Must be one of these symbols:
  60.  
  61. default -- place at location specified by `default-toolbar-position'
  62. top     -- place along the top of the frame
  63. bottom  -- place along the bottom of the frame
  64. right   -- place along the right edge of the frame
  65. left    -- place along the left edge of the frame
  66. none    -- no toolbar")
  67.  
  68. (defvar w3-toolbar-orientation 'top
  69.   "*Where to put the w3 toolbar.  Must be one of these symbols:
  70.  
  71. default -- place at location specified by `default-toolbar-position'
  72. top     -- place along the top of the frame
  73. bottom  -- place along the bottom of the frame
  74. right   -- place along the right edge of the frame
  75. left    -- place along the left edge of the frame
  76. none    -- no toolbar")
  77.  
  78. (defvar w3-toolbar-type 'pictures
  79.   "*What the toolbar looks like.  Must be one of these symbols:
  80.  
  81. pictures -- Show icons (without captions if in XEmacs 19.13)
  82. both     -- Show icons (with captions if in XEmacs 19.13)
  83. text     -- Show only text buttons
  84.  
  85. Only has any meaning in XEmacs 19.12 when w3-toolbar-orientation is
  86. not `none'.")
  87.  
  88. (defvar w3-toolbar
  89.   '([w3-toolbar-back-icon w3-backward-in-history t "Back in history"]
  90.     [w3-toolbar-forw-icon w3-forward-in-history t "Forward in history"]
  91.     [w3-toolbar-home-icon w3 t "Go home"]
  92.     [:style 2d :size 5]
  93.     [w3-toolbar-reld-icon w3-reload-document t "Reload document"]
  94.     [w3-toolbar-hotl-icon w3-show-hotlist t "View hotlist"]
  95.     [w3-toolbar-imag-icon w3-load-delayed-images w3-delayed-images
  96.               "Load images"]
  97.     [toolbar-file-icon w3-fetch t "Fetch a URL"]
  98.     [toolbar-printer-icon w3-mouse-print-this-url t "Print document"]
  99.     [w3-toolbar-find-icon isearch-forward t "Search"]
  100.     ;;[w3-toolbar-stop-icon undefined nil "Stop transaction"]
  101.     nil
  102.     [w3-toolbar-help-icon w3-show-info-node t "Help"])
  103.   "The toolbar for w3")
  104.  
  105. (defun w3-image-cache-timeout-function ()
  106.   (setq w3-graphics-list nil)
  107.   (garbage-collect))
  108.  
  109. (defun w3-start-image-cache-timer ()
  110.   (interactive)
  111.   (require 'itimer)
  112.   (let ((timer (get-itimer "w3-image-flush")))
  113.     (if timer (delete-itimer timer))
  114.     (start-itimer "w3-image-flush" 'w3-image-cache-timeout-function
  115.           300 300)))
  116.           
  117. (defun w3-toolbar-make-captioned-buttons ()
  118.   (mapcar
  119.    (function
  120.     (lambda (x)
  121.       (let* ((ext (if (featurep 'xpm) ".xpm" ".xbm"))
  122.          (base w3-toolbar-icon-directory)
  123.          (up (expand-file-name (concat x "-up" ext) base))
  124.          (dn (expand-file-name (concat x "-dn" ext) base))
  125.          (no (expand-file-name (concat x "-no" ext) base))
  126.          (cap-up (expand-file-name (concat x "-cap-up" ext) base))
  127.          (cap-dn (expand-file-name (concat x "-cap-dn" ext) base))
  128.          (cap-no (expand-file-name (concat x "-cap-no" ext) base))
  129.          (var (intern (concat "w3-toolbar-" x "-icon"))))
  130.     (set var
  131.          (toolbar-make-button-list up dn no cap-up cap-dn cap-no)))))
  132.    
  133.    '("back" "help" "find" "forw" "home"  "hotl" "imag" "reld")))
  134.  
  135. (defun w3-make-text-toolbar-button (text)
  136.   (let ((bgcol (or
  137.         (cdr-safe (assq 'background-toolbar-color (frame-parameters)))
  138.         "#befbbefbbefb")))
  139.     (if (featurep 'xpm)
  140.     (mapcar 'make-glyph (xpm-button-create text 0 "black" bgcol))
  141.       (xbm-button-create text 0))))
  142.  
  143. (defun w3-toolbar-make-text-buttons ()
  144.   (let ((bgcol (or (cdr-safe (assq 'background-toolbar-color
  145.                    (frame-parameters)))
  146.            "#befbbefbbefb")))
  147.     (setq w3-toolbar-back-icon (w3-make-text-toolbar-button "Back")
  148.       w3-toolbar-forw-icon (w3-make-text-toolbar-button "Forward")
  149.       w3-toolbar-home-icon (w3-make-text-toolbar-button "Home")
  150.       w3-toolbar-reld-icon (w3-make-text-toolbar-button "Reload")
  151.       w3-toolbar-hotl-icon (w3-make-text-toolbar-button "Hotlist")
  152.       w3-toolbar-imag-icon (w3-make-text-toolbar-button "Images")
  153.       w3-toolbar-open-icon (w3-make-text-toolbar-button "Open")
  154.       w3-toolbar-print-icon (w3-make-text-toolbar-button "Print")
  155.       w3-toolbar-find-icon (w3-make-text-toolbar-button "Find")
  156.       w3-toolbar-help-icon (w3-make-text-toolbar-button "Help!"))))
  157.  
  158. (defun w3-toolbar-make-picture-buttons ()
  159.   (mapcar
  160.    (function
  161.     (lambda (x)
  162.       (let* ((ext (if (featurep 'xpm) ".xpm" ".xbm"))
  163.          (base w3-toolbar-icon-directory)
  164.          (up (expand-file-name (concat x "-cap-up" ext) base))
  165.          (dn (expand-file-name (concat x "-cap-dn" ext) base))
  166.          (no (expand-file-name (concat x "-cap-no" ext) base))
  167.          (var (intern (concat "w3-toolbar-" x "-icon"))))
  168.     (set var
  169.          (cond
  170.           ((and (file-exists-p up) (file-exists-p dn)
  171.             (file-exists-p no))
  172.            (toolbar-make-button-list up dn no))
  173.           ((file-exists-p up)
  174.            (toolbar-make-button-list up))
  175.           (t nil))))))
  176.    '("back" "help" "find" "forw" "home" "hotl" "imag" "reld")))
  177.  
  178. (defun w3-toolbar-make-buttons ()
  179.   (cond
  180.    ((eq w3-toolbar-type 'text)
  181.     (w3-toolbar-make-text-buttons))
  182.    ((boundp 'toolbar-buttons-captioned-p)
  183.     (w3-toolbar-make-captioned-buttons))
  184.    (t
  185.     (w3-toolbar-make-picture-buttons))))
  186.  
  187. (defun w3-link-is-defined (rel &optional rev)
  188.   (or
  189.    (cdr-safe (assoc rel (cdr-safe (assoc "Parent of" w3-current-links))))
  190.    (cdr-safe (assoc (or rev rel) (cdr-safe (assoc "Child of"
  191.                           w3-current-links))))))
  192.  
  193. ;; Need to create w3-toolbar-glos-icon
  194. ;;                w3-toolbar-toc-icon
  195. ;;                w3-toolbar-copy-icon
  196. (defvar w3-link-toolbar
  197.   '([info::toolbar-prev-icon
  198.      (w3-fetch (w3-link-is-defined "previous" "next"))
  199.      (w3-link-is-defined "previous" "next")
  200.      "Back"]
  201.     [info::toolbar-next-icon
  202.      (w3-fetch (w3-link-is-defined "next" "previous"))
  203.      (w3-link-is-defined "next" "previous")
  204.      "Next"]
  205.     [info::toolbar-up-icon
  206.      (w3-fetch (w3-link-is-defined "up" "down"))     
  207.      (w3-link-is-defined "up" "down")
  208.      "Up"]
  209.     [w3-toolbar-home-icon
  210.      (w3-fetch (w3-link-is-defined "home"))
  211.      (w3-link-is-defined "home")
  212.      "Home"]
  213.     [w3-toolbar-toc-icon
  214.      (w3-fetch (w3-link-is-defined "toc"))
  215.      (w3-link-is-defined "toc")
  216.      "Contents"]
  217.     [w3-toolbar-find-icon
  218.      (w3-fetch (w3-link-is-defined "index"))
  219.      (w3-link-is-defined "index")
  220.      "Index"]
  221.     [w3-toolbar-glos-icon
  222.      (w3-fetch (w3-link-is-defined "glossary"))
  223.      (w3-link-is-defined "glossary")
  224.      "Glossary"]
  225.     [w3-toolbar-copy-icon
  226.      (w3-fetch (w3-link-is-defined "copyright"))
  227.      (w3-link-is-defined "copyright")
  228.      "Copyright"]
  229.     [w3-toolbar-hotl-icon
  230.      (w3-fetch (w3-link-is-defined "bookmark"))
  231.      (w3-link-is-defined "bookmark")
  232.      "Bookmarks"]
  233.     nil
  234.     [w3-toolbar-help-icon
  235.      (w3-fetch (w3-link-is-defined "help"))
  236.      (w3-link-is-defined "help")
  237.      "Help"]
  238.     ))
  239.  
  240. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  241. ;;; Spiffy new menus for XEmacs 19.12 only
  242. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  243. (defun w3-hotlist-menu-constructor (menu-items)
  244.   (let ((hot-menu nil)
  245.     (hot w3-hotlist))
  246.     (while hot
  247.       (setq hot-menu (cons (vector
  248.                 (w3-truncate-menu-item (car (car hot)))
  249.                 (list 'w3-fetch (car (cdr (car hot))))
  250.                 t) hot-menu)
  251.         hot (cdr hot)))
  252.     (or hot-menu '(["No Hotlist" undefined nil]))))
  253.  
  254. (defun w3-image-type-constructor (menu-items)
  255.   (let ((nodes menu-items) cur)
  256.     (if (not nodes)
  257.     (setq menu-items
  258.           (mapcar
  259.            (function
  260.         (lambda (data)
  261.           (let ((typ (car data)))
  262.             (vector typ
  263.                 (list 'w3-ins-or-del-graphic typ)
  264.                 ':style 'toggle
  265.                 ':selected
  266.                 (list 'assoc typ 'w3-allowed-image-types)))))
  267.            w3-graphic-converter-alist))
  268.       )
  269.     menu-items))
  270.  
  271. (defun w3-image-quality-constructor (menu-items)
  272.   (let ((nodes menu-items)
  273.     (cur nil))
  274.     (while nodes
  275.       (setq cur (car nodes)
  276.         nodes (cdr nodes))
  277.       (if (not (vectorp cur))
  278.       nil
  279.     (cond
  280.      ((string-match "Use " (aref cur 0))
  281.       (aset cur 0 (format "Use %dx%dx%dx colormap" w3-color-max-red
  282.                    w3-color-max-green w3-color-max-blue)))
  283.      ((string-match "Dither to" (aref cur 0))
  284.       (aset cur 0 (format "Dither to %d colors"
  285.                   (* w3-color-max-red w3-color-max-green
  286.                  w3-color-max-blue))))
  287.      (t nil))))
  288.     menu-items))
  289.  
  290. (defun w3-build-links-helper (extent maparg)
  291.   (let ((x (extent-property extent 'w3)))
  292.     (if (and x (not (null (nth 1 x))))
  293.     (setq w3-links-menu
  294.           (nconc w3-links-menu
  295.              (list
  296.               (vector (w3-truncate-menu-item
  297.                    (w3-fix-spaces
  298.                 (buffer-substring
  299.                  (extent-start-position extent)
  300.                  (extent-end-position extent))))
  301.                   (list 'url-maybe-relative (nth 1 x))
  302.                   t))))))
  303.   nil)
  304.  
  305. (defun w3-links-menu-constructor (menu-items)
  306.   (or menu-items
  307.       (progn
  308.     (map-extents 'w3-build-links-helper)
  309.     (setq w3-links-menu (w3-breakup-menu w3-links-menu
  310.                          w3-max-menu-length))
  311.     (or w3-links-menu '(["No Links" undefined nil])))))
  312.  
  313. (defun w3-toolbar-from-orientation (orientation)
  314.   (cond
  315.    ((eq 'default w3-toolbar-orientation) default-toolbar)
  316.    ((eq 'bottom w3-toolbar-orientation) bottom-toolbar)
  317.    ((eq 'top w3-toolbar-orientation) top-toolbar)
  318.    ((eq 'left w3-toolbar-orientation) left-toolbar)
  319.    ((eq 'right w3-toolbar-orientation) right-toolbar)))
  320.  
  321. (defun w3-toolbar-dimension-from-orientation (orientation)
  322.   (cond
  323.    ((eq 'default w3-toolbar-orientation) nil)
  324.    ((eq 'bottom w3-toolbar-orientation) bottom-toolbar-height)
  325.    ((eq 'top w3-toolbar-orientation) top-toolbar-height)
  326.    ((eq 'left w3-toolbar-orientation) left-toolbar-width)
  327.    ((eq 'right w3-toolbar-orientation) right-toolbar-width)))
  328.  
  329. (defun w3-ensure-toolbar-visible (orientation)
  330.   ;; Make sure a certain toolbar is visible if necessary
  331.   ;; This can modify frame parameters, so watch out.
  332.   (let ((dimension (w3-toolbar-dimension-from-orientation orientation))
  333.     (toolbar   (w3-toolbar-from-orientation orientation))
  334.     (dimensions nil)
  335.     (widths nil)
  336.     (heights nil)
  337.     (needs nil)
  338.     (has nil))
  339.     (if (and dimension toolbar
  340.          (setq toolbar (specifier-instance toolbar)))
  341.     (progn
  342.       (setq dimensions (mapcar
  343.                 (function
  344.                  (lambda (glyph)
  345.                    (and (glyphp glyph)
  346.                     (cons (glyph-width glyph)
  347.                       (glyph-height glyph)))))
  348.                 (mapcar 'car
  349.                     (delq nil
  350.                       (mapcar
  351.                        (function (lambda (x)
  352.                                (and x
  353.                                 (symbol-value
  354.                                  (aref x 0)))))
  355.                        toolbar))))
  356.         widths (sort (mapcar 'car dimensions) '>=)
  357.         heights (sort (mapcar 'cdr dimensions) '>=)
  358.         needs (+ 7 (if (memq orientation '(top bottom))
  359.                   (car heights)
  360.                 (car widths)))
  361.         has (specifier-instance dimension))
  362.       (if (<= has needs)
  363.           (set-specifier dimension (cons (selected-frame) needs)))))))
  364.                  
  365. (defun w3-toolbar-active ()
  366.   (interactive)
  367.   (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
  368.     (if (and toolbar (specifier-instance toolbar))
  369.     t
  370.       nil)))
  371.  
  372. (defun w3-toggle-link-toolbar ()
  373.   (interactive)
  374.   (require 'info)            ; For some toolbar buttons
  375.   (let* ((w3-toolbar-orientation w3-link-toolbar-orientation)
  376.      (toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
  377.     (if toolbar
  378.     (if (w3-toolbar-active)
  379.         (set-specifier toolbar (cons (current-buffer) nil))
  380.       (set-specifier toolbar (cons (current-buffer) w3-link-toolbar))))))
  381.  
  382. (defun w3-toggle-toolbar ()
  383.   (interactive)
  384.   (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
  385.     (if (w3-toolbar-active)
  386.     (set-specifier toolbar (cons (current-buffer) nil))
  387.       (set-specifier toolbar (cons (current-buffer) w3-toolbar)))))
  388.  
  389. (defun w3-menu-xemacs-global-menubar ()
  390.   (save-excursion
  391.     (set-buffer (get-buffer-create "*scratch*"))
  392.     current-menubar))
  393.  
  394. (defvar w3-menu
  395.   (list
  396.    '("File"
  397.      :filter file-menu-filter
  398.      ["Open URL..." w3-fetch t]
  399.      ["Open File..." w3-open-local t]
  400.      ["Open in New Frame..." w3-fetch-other-frame t]
  401.      "---"
  402.      ["Save" save-buffer t nil]
  403.      ("Save As..."
  404.       ["HTML" (w3-save-as "HTML Source") t]
  405.       ["Formatted Text" (w3-save-as "Formatted Text") t]
  406.       ["LaTeX" (w3-save-as "LaTeX Source") t]
  407.       ["PostScript" (w3-save-as "PostScript") t]
  408.       ["Binary" (w3-save-as "Binary") t])
  409.      "---"
  410.      ["New Frame"        make-frame        t]
  411.      ["Delete Frame"        delete-frame        t]
  412.      "---"
  413.      ("Print As..."
  414.       ["PostScript" (w3-print-this-url nil "PostScript") t]
  415.       ["Formatted Text" (w3-print-this-url nil "Formatted Text") t]
  416.       ["HTML Source" (w3-print-this-url nil "HTML Source") t]
  417.       ["LaTeX'd" (w3-print-this-url nil "LaTeX'd") t])
  418.      ("Mail Document..."
  419.       ["HTML" (w3-mail-current-document nil "HTML Source") t]
  420.       ["Formatted Text" (w3-mail-current-document nil "Formatted Text") t]
  421.       ["PostScript" (w3-mail-current-document nil "PostScript") t]
  422.       ["LaTeX Source" (w3-mail-current-document nil "LaTeX Source") t])
  423.      ["Add Annotation" w3-annotation-add w3-personal-annotation-directory]
  424.      "---"
  425.      ["Leave Buffer" w3-leave-buffer t]
  426.      ["Kill Buffer" w3-quit t nil]
  427.      "---:shadowDoubleEtchedIn"
  428.      ["Exit XEmacs" save-buffers-kill-emacs t]
  429.      )
  430.    '("Edit"
  431.      :filter edit-menu-filter
  432.      ["Undo"            advertised-undo           t]
  433.      ["Cut"            x-kill-primary-selection   t]
  434.      ["Copy"            x-copy-primary-selection   t]
  435.      ["Paste"            x-yank-clipboard-selection t]
  436.      ["Clear"            x-delete-primary-selection t]
  437.      "----"
  438.      ["Search..."        isearch-forward        t]
  439.      ["Search Backward..."    isearch-backward    t]
  440.      ["Replace..."        query-replace        t]
  441.      "----"
  442.      ["Search (Regexp)..."    isearch-forward-regexp    t]
  443.      ["Search Backward (Regexp)..." isearch-backward-regexp t]
  444.      ["Replace (Regexp)..."    query-replace-regexp    t]
  445.      "----"
  446.      ["Goto Line..."        goto-line        t]
  447.      ["What Line"        what-line        t]
  448.      "----"
  449.      ["Start Macro Recording"    start-kbd-macro          (not defining-kbd-macro)]
  450.      ["End Macro Recording"    end-kbd-macro        defining-kbd-macro]
  451.      ["Execute Last Macro"    call-last-kbd-macro    last-kbd-macro]
  452.      )
  453.    '("View"
  454.      ["Document Information" w3-document-information t]
  455.      ["Document Source" w3-source-document t]
  456.      ["Load Images" w3-load-delayed-images w3-delayed-images]
  457.      "----"
  458.      ["Refresh" w3-refresh-buffer w3-current-parse]
  459.      ["Reload" w3-reload-document (and (url-view-url t)
  460.                        (not (equal (url-view-url t) "")))]
  461.      "----"
  462.      ["Show URL" url-view-url t]
  463.      ["Show URL At Point" w3-view-this-url t])
  464.    '("Go"
  465.      ["Forward" w3-forward-in-history t]
  466.      ["Backward" w3-backward-in-history t]
  467.      ["Home" w3 w3-default-homepage]
  468.      ["View History..." w3-show-history-list url-keep-history]
  469.      "----"
  470.      ("Links" :filter w3-links-menu-constructor))
  471.    '("Hotlist"
  472.      ["View Hotlist..." w3-show-hotlist w3-hotlist]
  473.      ["Add this document to hotlist" w3-hotlist-add-document t]
  474.      ["Delete item from hotlist" w3-hotlist-delete t]
  475.      ["Rename item in hotlist" w3-hotlist-rename-entry t]
  476.      ["Append new hotlist file" w3-hotlist-append t]
  477.      "----"
  478.      ("Hotlist" :filter w3-hotlist-menu-constructor))
  479.    '("Options"
  480.      ["Show Toolbar" w3-toggle-toolbar
  481.       :style toggle :selected (w3-toolbar-active)]
  482.      ["Auto Load Images" (setq w3-delay-image-loads (not w3-delay-image-loads))
  483.       :style toggle :selected (not w3-delay-image-loads)]
  484.      ["Auto Load MPEGs" (setq w3-delay-mpeg-loads (not w3-delay-mpeg-loads))
  485.       :style toggle :selected (not w3-delay-mpeg-loads)]
  486.      "----"
  487.      ("Image Quality"
  488.       :filter w3-image-quality-constructor
  489.       ["Never dither" (setq w3-color-use-reducing nil)
  490.        :style radio :selected (null w3-color-use-reducing)]
  491.       ["Use " (setq w3-color-filter 'ppmquant
  492.             w3-color-use-reducing t)
  493.        :style radio :selected (and w3-color-use-reducing
  494.                    (eq w3-color-filter 'ppmquant))]
  495.       ["Dither to " (setq w3-color-filter 'ppmdither
  496.               w3-color-use-reducing t)
  497.        :style radio :selected (and w3-color-use-reducing
  498.                    (eq w3-color-filter 'ppmdither))]
  499.       ["Other..." (setq w3-color-filter
  500.             (read-string "Filter: "
  501.                      (if (stringp w3-color-filter)
  502.                      w3-color-filter ""))
  503.             w3-color-use-reducing t)
  504.        :style radio :selected (and w3-color-use-reducing
  505.                    (stringp w3-color-filter))])
  506.      ("Image Types" :filter w3-image-type-constructor)
  507.      ["Flush Image Cache" (setq w3-graphics-list nil) w3-graphics-list]
  508.      "----"
  509.      ["Privacy Mode" (progn
  510.                (setq url-privacy-level
  511.                  (if (eq 'paranoid url-privacy-level)
  512.                  'none
  513.                    'paranoid))
  514.                (url-setup-privacy-info))
  515.       :style toggle :selected (not (eq url-privacy-level 'none))]
  516.      ["Color Printing" (setq ps-print-color-p (not ps-print-color-p))
  517.       :style toggle :selected (and (boundp 'ps-print-color-p)
  518.                    ps-print-color-p)]
  519.      ["Honor Automatic Refreshes" (setq url-honor-refresh-requests
  520.                     (not url-honor-refresh-requests))
  521.       :style toggle :selected (not (null url-honor-refresh-requests))]
  522.      ["Honor Color Requests" (setq w3-user-colors-take-precedence
  523.                    (not w3-user-colors-take-precedence))
  524.       :style toggle :selected (not w3-user-colors-take-precedence)]
  525.      "----"
  526.      ["Download to disk" (setq w3-dump-to-disk (not w3-dump-to-disk))
  527.       :style toggle :selected w3-dump-to-disk]
  528.      ["Caching" (setq url-automatic-caching (not url-automatic-caching))
  529.       :style toggle :selected url-automatic-caching]
  530.      ["Use Cache Only" (setq url-standalone-mode (not url-standalone-mode))
  531.       :style toggle :selected url-standalone-mode]
  532.      "----"
  533.      ["Fancy Gopher" (setq url-use-hypertext-gopher
  534.                    (not url-use-hypertext-gopher))
  535.       :style toggle :selected url-use-hypertext-gopher]
  536.      ["Fancy Directory Listings" (setq url-use-hypertext-dired
  537.                        (not url-use-hypertext-dired))
  538.       :style toggle :selected url-use-hypertext-dired]
  539.      "----"
  540.      ["Save Options" w3-menu-save-options t])
  541.    '("Buffers"
  542.      :filter buffers-menu-filter
  543.      ["List All Buffers" list-buffers t]
  544.      "--!here")
  545.    ["Emacs" w3-menu-toggle-menubar t]
  546.    nil
  547.    '("Help"
  548.      ["About Emacs-w3" (w3-fetch "about:") t]
  549.      ["Manual" (w3-fetch (concat w3-documentation-root "docs/w3_toc.html")) t]
  550.      "---"
  551.      ["Version Information..."
  552.       (w3-fetch (concat w3-documentation-root "help_on_" 
  553.             w3-version-number ".html")) t]
  554.      ["On Window" (w3-fetch (concat w3-documentation-root
  555.                     "window-help.html")) t]
  556.      ["On FAQ" (w3-fetch (concat w3-documentation-root
  557.                  "FAQ.html")) t]
  558.      "---"
  559.      ["On HTML" (w3-fetch "http://www.ncsa.uiuc.edu/General/Internet/WWW/HTMLPrimer.html") t]
  560.      ["On URLs" (w3-fetch "http://www.ncsa.uiuc.edu/demoweb/url-primer.html") t]
  561.      ["Mail Developer(s)" w3-submit-bug t])))
  562.  
  563. (defun w3-menu-toggle-menubar ()
  564.   (interactive)
  565.   (if (null (car (find-menu-item current-menubar '("Emacs"))))
  566.       (set-buffer-menubar w3-menu)
  567.     (set-buffer-menubar (copy-sequence (w3-menu-xemacs-global-menubar)))
  568.     (add-menu-button nil ["W3" w3-menu-toggle-menubar t] nil)))
  569.  
  570. (defun w3-menu-save-options ()
  571.   (interactive)
  572.   (let ((output-buffer (find-file-noselect
  573.             (expand-file-name
  574.              (concat "~" init-file-user "/.emacs"))))
  575.     output-marker)
  576.     (save-excursion
  577.       (set-buffer output-buffer)
  578.       ;;
  579.       ;; Find and delete the previously saved data, and position to write.
  580.       ;;
  581.       (goto-char (point-min))
  582.       (if (re-search-forward "^;; W3 Options Settings *\n" nil 'move)
  583.       (let ((p (match-beginning 0)))
  584.         (goto-char p)
  585.         (or (re-search-forward
  586.          "^;; End of W3 Options Settings *\\(\n\\|\\'\\)"
  587.          nil t)
  588.         (error "can't find END of saved state in .emacs"))
  589.         (delete-region p (match-end 0)))
  590.     (goto-char (point-max))
  591.     (insert "\n"))
  592.       (setq output-marker (point-marker))
  593.       (let ((print-readably t)
  594.         (print-escape-newlines t)
  595.         (standard-output output-marker))
  596.     (princ ";; W3 Options Settings\n")
  597.     (princ ";; ===================\n")
  598.     (mapcar (function
  599.          (lambda (var)
  600.            (princ "  ")
  601.            (if (and (symbolp var) (boundp var))
  602.                (prin1 (list 'setq-default var
  603.                     (let ((val (symbol-value var)))
  604.                       (if (or (memq val '(t nil))
  605.                           (and (not (symbolp val))
  606.                            (not (listp val))))
  607.                       val
  608.                     (list 'quote val))))))
  609.            (if var (princ "\n"))))
  610.         '(
  611.           w3-delay-image-loads
  612.           w3-delay-mpeg-loads
  613.           ps-print-color-p
  614.           w3-color-use-reducing
  615.           w3-color-filter
  616.           w3-dump-to-disk
  617.           url-automatic-caching
  618.           url-standalone-mode
  619.           url-use-hypertext-gopher
  620.           url-use-hypertext-dired
  621.           url-proxy-services
  622.           url-be-asynchronous
  623.           w3-default-homepage
  624.           url-privacy-level
  625.           w3-toolbar-orientation
  626.           )
  627.         )
  628.     (princ ";; ==========================\n")
  629.     (princ ";; End of W3 Options Settings\n")))
  630.     (set-marker output-marker nil)
  631.     (save-excursion
  632.       (set-buffer output-buffer)
  633.       (save-buffer))
  634.     ))
  635.  
  636.  
  637. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  638. ;;; Make the menu acceptable to old versions of Lucid Emacs/XEmacs
  639. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  640. (defun w3-downgrade-menus ()
  641.   "Strip out the XEmacs 19.12'isms from the w3 menu"
  642.   (require 'pp)
  643.   (let ((need-to-replace nil))
  644.     (save-excursion
  645.       (set-buffer (get-buffer-create " *w3-temp*"))
  646.       (erase-buffer)
  647.       (pp w3-menu (current-buffer))
  648.       (goto-char (point-min))
  649.       (if (search-forward ":filter" nil t)
  650.       (setq need-to-replace t))
  651.       (goto-char (point-min))
  652.       (delete-matching-lines ":filter")
  653.       (goto-char (point-min))
  654.       (w3-replace-regexp "---:shadowDoubleEtchedIn" "----")
  655.       (goto-char (point-min))
  656.       (if (search-forward "Show Toolbar" nil t)
  657.       (progn
  658.         (beginning-of-line)
  659.         (kill-sexp 1)))
  660.       (goto-char (point-min))
  661.       (if (search-forward "View History..." nil t)
  662.       (progn
  663.         (beginning-of-line)
  664.         (forward-sexp 2)
  665.         (end-of-line)
  666.         (insert ")")))
  667.       (if (search-forward "Append new hotlist file" nil t)
  668.       (progn
  669.         (beginning-of-line)
  670.         (forward-sexp 2)
  671.         (end-of-line)
  672.         (insert ")")))
  673.       (if (and need-to-replace
  674.            (search-forward "Never dither" nil t))
  675.       (progn
  676.         (beginning-of-line)
  677.         (insert "(\"Image Quality\"\n")))
  678.       (goto-char (point-min))
  679.       (if (and need-to-replace
  680.            (search-forward "Exit XEmacs" nil t))
  681.       (progn
  682.         (end-of-line)
  683.         (insert "\n(\"Edit\"\n")))
  684.       (goto-char (point-min))
  685.       (if (and need-to-replace
  686.            (search-forward "Save Options" nil t))
  687.       (progn
  688.         (end-of-line)
  689.         (insert "\n(\"Buffers\"\n")))
  690.       (goto-char (point-min))
  691.       (if (and (= emacs-minor-version 6)
  692.            (search-forward "Options" nil t))
  693.       (progn
  694.         (beginning-of-line)
  695.         (kill-sexp 1)
  696.         (insert
  697.          "(\"Options\"
  698.         [\"Delay Image Load\" (setq w3-delay-image-loads (not w3-delay-image-loads))
  699.          nil]
  700.         [\"Flush Image Cache\" (setq w3-graphics-list nil) t]
  701.         [\"Flush Disk Cache\" (url-flush-cache) t]
  702.         (\"Hypertext Gopher Mode\"
  703.          [\"Turn On\" (setq url-use-hypertext-gopher t) t]
  704.          [\"Turn Off\" (setq url-use-hypertext-gopher nil) t])
  705.         (\"Hypertext Dired Mode\"
  706.          [\"Turn On\" (setq url-use-hypertext-dired t) t]
  707.          [\"Turn Off\" (setq url-use-hypertext-dired nil) t])
  708.         [\"Clear History\" (progn
  709.                    (setq url-history-list nil)
  710.                    (disable-menu-item '(\"Options\" \"Clear History\"))) t])")
  711.         (goto-char (point-min))))
  712.       (and need-to-replace (insert "((\"File\"\n"))
  713.       (goto-char (point-min))
  714.       (if (not need-to-replace)
  715.       (w3-replace-regexp "\"----\"))" "\"----\")"))
  716.       (goto-char (point-min))
  717.       (setq w3-menu (read (current-buffer)))
  718.       (kill-buffer (current-buffer)))))
  719.  
  720. (defun w3-show-info-node ()
  721.   (interactive)
  722.   (Info-goto-node "(w3.info)Top"))
  723.  
  724. (defun w3-mouse-print-this-url (&optional e)
  725.   (interactive "e")
  726.   (let ((descr '("Print document as"
  727.          ["PostScript" (w3-print-this-url nil "PostScript") t]
  728.          ["Formatted Text" (w3-print-this-url nil "Formatted Text") t]
  729.          ["HTML Source" (w3-print-this-url nil "HTML Source") t]
  730.          ["LaTeX'd" (w3-print-this-url nil "LaTeX'd") t]
  731.          nil
  732.          ["Cancel" (beep) t])))
  733.     (popup-dialog-box descr)))
  734.  
  735. (defun w3-ins-or-del-graphic (typ)
  736.   (if (assoc typ w3-allowed-image-types)
  737.       (setq w3-allowed-image-types
  738.         (mapcar (function (lambda (x) (if (equal typ (car x)) nil x)))
  739.             w3-allowed-image-types))
  740.     (setq w3-allowed-image-types (cons (list typ) w3-allowed-image-types))))
  741.  
  742. (defun w3-create-faces ()
  743.   "Create faces, the XEmacs way"
  744.   
  745.   (make-face w3-node-style)
  746.   (make-face w3-default-style)
  747.   (make-face w3-visited-node-style)
  748.   
  749.   (if (not (face-differs-from-default-p w3-node-style))
  750.       (copy-face 'bold w3-node-style))
  751.   (if (not (face-differs-from-default-p w3-visited-node-style))
  752.       (copy-face 'bold-italic w3-visited-node-style)))
  753.  
  754. (fset 'w3-delete-zone 'delete-extent)
  755. (fset 'w3-zone-end 'extent-end-position)
  756. (fset 'w3-zone-start 'extent-start-position)
  757. (fset 'w3-zone-eq 'eq)
  758.  
  759. (if (< emacs-minor-version 12)
  760.     (defun w3-insert (&rest args)
  761.       (let ((start (point))
  762.         (zones nil))
  763.     (map-extents (function
  764.               (lambda (x y)
  765.             (setq zones (cons x zones))
  766.             nil)) nil start (if (eobp) start (1+ start)))
  767.     (apply 'insert-before-markers args)
  768.     (mapcar (function
  769.          (lambda (zone)
  770.            (cond
  771.             ((= (point) (extent-end-position zone)) nil)
  772.             ((< (extent-end-position zone) (point))
  773.              (set-extent-endpoints zone (extent-end-position zone)
  774.                        (point)))
  775.             ((= (extent-start-position zone) start)
  776.              (set-extent-endpoints zone (point)
  777.                        (extent-end-position zone))))))
  778.         zones)))
  779.   (fset 'w3-insert 'insert-before-markers))
  780.  
  781. (defun w3-zone-hidden-p (start end)
  782.   "Return t iff the region from start to end is invisible."
  783.   (and (extent-at (1+ start))
  784.        (extent-property (extent-at (1+ start)) 'invisible)))
  785.  
  786. (defun w3-unhide-zone (start end)
  787.   "Make a region from START TO END visible. (xemacs)"
  788.   (map-extents
  789.    (function
  790.     (lambda (ext)
  791.       (if (and (= start (extent-start-position ext))
  792.            (= end   (extent-end-position ext))
  793.            (extent-property ext 'invisible))
  794.       (progn (delete-extent ext) t)
  795.     nil))) start end))
  796.  
  797. (defun w3-hide-zone (start end)
  798.   "Make a region from START to END invisible. (xemacs)"
  799.   (set-extent-property (make-extent start end) 'invisible t))
  800.  
  801. (defun w3-fix-extent-endpoints ()
  802.   "Make sure no extents contain trailing whitespace/newlines"
  803.   ;; Using char-after instead of skip-chars-backward means we don't have
  804.   ;; to actually move point to do this.
  805.   (let ((skip-chars (list ?\t ?\r ?\n ?\ )))
  806.     (map-extents (function
  807.           (lambda (ext maparg)
  808.             (if (or (and (fboundp 'annotationp)
  809.                  (annotationp ext))
  810.                 (extent-property ext 'w3graphic)
  811.                 (extent-property ext 'w3delayed)
  812.                 ) nil
  813.               (let ((st (extent-start-position ext))
  814.                 (nd (extent-end-position ext))
  815.                 (ch nil))
  816.             (while (memq (char-after (1- nd)) skip-chars)
  817.               (setq nd (1- nd)
  818.                 ch t))
  819.             (while (memq (char-after st) skip-chars)
  820.               (setq st (1+ st)
  821.                 ch t))
  822.             (if ch
  823.                 (if (<= nd st)
  824.                 (delete-extent ext)
  825.                   (set-extent-endpoints ext st nd)))))
  826.             nil)))))
  827.  
  828. (defun w3-all-zones ()
  829.   (let ((cur (next-extent (current-buffer)))
  830.     (all nil))
  831.     (while cur
  832.       (setq all (cons cur all))
  833.       (setq cur (next-extent cur)))
  834.     all))
  835.  
  836. (defun w3-sensitize-menu ()
  837.   (if (and (eq major-mode 'w3-mode) current-menubar
  838.        (car (find-menu-item current-menubar '("Emacs"))))
  839.       (let ((hot-menu nil)
  840.         (hot w3-hotlist)
  841.         (image (find-menu-item current-menubar
  842.                    '("Options" "Image Quality"))))
  843.     (if (setq image (cdr (car image)))
  844.         (progn
  845.           (aset (nth 1 image) 0 (format "Use %d colors"
  846.                         (* w3-color-max-red
  847.                            w3-color-max-green
  848.                            w3-color-max-blue)))
  849.           (aset (nth 2 image) 0 (format "Dither to %dx%dx%d colormap"
  850.                         w3-color-max-red
  851.                         w3-color-max-green
  852.                         w3-color-max-blue))))
  853.     (while hot
  854.       (setq hot-menu (cons (vector
  855.                 (w3-truncate-menu-item (car (car hot)))
  856.                 (list 'w3-fetch (car (cdr (car hot))))
  857.                 t) hot-menu)
  858.         hot (cdr hot)))
  859.     (if (cdr w3-links-menu)
  860.         (add-submenu '("Go") (cons "Links" (w3-breakup-menu
  861.                         (cdr w3-links-menu)
  862.                         w3-max-menu-length)))
  863.       (condition-case ()
  864.           (delete-menu-item '("Go" "Links"))
  865.         (error nil)))
  866.     (if hot-menu
  867.         (add-submenu '("Hotlist") (cons "Hotlist"
  868.                        (w3-breakup-menu hot-menu
  869.                             w3-max-menu-length)))
  870.       (condition-case ()
  871.           (delete-menu-item '("Hotlist" "Hotlist")))))
  872.     t))
  873.  
  874. (defun w3-find-specific-link (link)
  875.   "Find LINK in the current document"
  876.   (let ((dat (map-extents
  877.           (function
  878.            (lambda (ext maparg)
  879.          (if (equal link (extent-property ext 'w3-ident))
  880.              (cons ext (extent-start-position ext))
  881.            nil))))))
  882.     (cond
  883.      (dat
  884.       (goto-char (cdr dat))
  885.       (message "Found link %s" link)
  886.       (force-highlight-extent (car dat) t)
  887.       (while (not (input-pending-p))
  888.     (sit-for 1))
  889.       (force-highlight-extent (car dat) nil)))))     
  890.  
  891. (defun w3-zone-data (zone)
  892.   "Return the data associated with zone"
  893.   (if (extentp zone)
  894.       (let ((link (extent-property zone 'w3))
  895.         (grph (extent-property zone 'w3graphic))
  896.         (form (extent-property zone 'w3form))
  897.         (list (extent-property zone 'w3expandlist))
  898.         (mpeg (extent-property zone 'w3mpeg))
  899.         (dely (extent-property zone 'w3delayed)))
  900.     (cond
  901.      (link (cons 'w3 link))
  902.      (form (cons 'w3form form))
  903.      (dely (cons 'w3delayed dely))
  904.      (grph (cons 'w3graphic grph))
  905.      (mpeg (cons 'w3mpeg mpeg))
  906.      (list (cons 'w3expandlist list))
  907.      (t nil)))
  908.     zone))
  909.  
  910. (defun w3-zone-at (pt)
  911.   "Return the extent at point PT that is either a link or a forms area."
  912.   (let ((link (extent-at pt (current-buffer) 'w3))
  913.     (form (extent-at pt (current-buffer) 'w3form))
  914.     (grph (extent-at pt (current-buffer) 'w3graphic))
  915.     (list (extent-at pt (current-buffer) 'w3expandlist))
  916.     (mpeg (extent-at pt (current-buffer) 'w3mpeg))
  917.     (dely (extent-at pt (current-buffer) 'w3delayed)))
  918.     (cond
  919.      (link link)
  920.      (form form)
  921.      (dely dely)
  922.      (grph grph)
  923.      (list list)
  924.      (mpeg mpeg)
  925.      (t nil))))
  926.  
  927. (defun w3-mouse-handler (e)
  928.   "Function to message the url under the mouse cursor"
  929.   (let* ((pt (event-point e))
  930.      (props (and pt (extent-properties-at pt)))
  931.      (link (nth 1 (nth 1 (memq 'w3 props)))) ; The link info if it exists
  932.      (form (nth 1 (memq 'w3form props)))      ; The form info it it exists
  933.      (dely (nth 0 (nth 1 (memq 'w3delayed props))))     ; The delayed img info
  934.      (mpeg (nth 1 (memq 'w3mpeg props)))     ; the delayed mpeg info
  935.      (imag (nth 1 (memq 'w3graphic props)))) ; The image info if it exists
  936.     (cond
  937.      (link (message "%s" link))
  938.      (form
  939.       (let ((args (nth 0 form)))
  940.     (cond
  941.      ((string= "SUBMIT" (nth 1 form))
  942.       (message "Submit form to %s" (cdr-safe (assoc "action" args))))
  943.      ((string= "RESET" (nth 1 form))
  944.       (message "Reset form contents"))
  945.      (t
  946.       (message "Form entry (name=%s, type=%s)" (nth 2 form)
  947.            (if (equal "" (nth 1 form))
  948.                "text"
  949.              (downcase (nth 1 form))))))))
  950.      (dely (message "Delayed image (%s)" (car dely)))
  951.      (imag (message "Inlined image (%s)" (car imag)))
  952.      (mpeg (message "Delayed mpeg (%s)" (car mpeg)))
  953.      (t (message "")))))
  954.  
  955. (defun w3-next-extent (xt)
  956.   "Return the next extent after XT that is a link or a forms area."
  957.   (let ((x nil))
  958.     (map-extents (function (lambda (extent maparg)
  959.                  (if (or (extent-property extent 'w3)
  960.                      (extent-property extent 'w3form))
  961.                  (setq x extent) nil)))
  962.          (current-buffer)
  963.          (if xt (1+ (extent-end-position xt)) (point))
  964.          (point-max))
  965.     x))
  966.  
  967. (defun w3-forward-link (p)
  968.   "Move forward to the next link in the document.  Error if no more links."
  969.   (interactive "P")
  970.   (setq p (or p 1))
  971.   (if (< p 0)
  972.       (w3-back-link (- p))
  973.     (if (/= 1 p)
  974.     (w3-forward-link (1- p)))
  975.     (let ((x (w3-next-extent (or (extent-at (point) nil 'w3)
  976.                  (extent-at (point) nil 'w3form)))))
  977.       (if x (goto-char (extent-start-position x))
  978.     (error "No more links.")))))
  979.  
  980. (defun w3-previous-extent (xt)
  981.   (let ((x nil))
  982.     (map-extents (function (lambda (extent maparg)
  983.                  (if (or (extent-property extent 'w3)
  984.                      (extent-property extent 'w3form))
  985.                    (setq x extent)) nil))
  986.          (current-buffer) (point-min)
  987.          (if xt (extent-start-position xt) (point)))
  988.     x))
  989.  
  990. (defun w3-back-link (p)
  991.   "Go back link"
  992.   (interactive "P")
  993.   (setq p (or p 1))
  994.   (if (< p 0)
  995.       (w3-forward-link (- p))
  996.     (if (/= 1 p)
  997.     (w3-back-link (1- p)))
  998.     (let ((x (w3-previous-extent (extent-at (point)))))
  999.       (if x (goto-char (extent-start-position x))
  1000.     (error "No previous link.")))))
  1001.  
  1002. (defun w3-extend-zone (zone new-end)
  1003.   (if (extent-property zone 'detached)
  1004.       (insert-extent zone (point) new-end)
  1005.     (let ((beg (extent-start-position zone)))
  1006.       (set-extent-endpoints zone beg new-end))))
  1007.  
  1008. (defun w3-add-zone (start end style data &optional highlight)
  1009.   "Add highlighting (xemacs)"
  1010.   (if (markerp start) (setq start (marker-position start)))
  1011.   (if (markerp end)   (setq end   (marker-position end)))
  1012.   (let ((ext (make-extent start end)))
  1013.     (set-extent-property ext 'face style)
  1014.     (set-extent-property ext 'detachable nil)
  1015.     (set-extent-property ext 'highlight highlight)
  1016.     (set-extent-property ext (car data) (cdr data))
  1017.     (cond
  1018.      ((eq (car data) 'w3)
  1019.       (set-extent-property ext 'priority 2)
  1020.       (if (nth 1 data) (set-extent-property ext 'w3-ident (nth 1 data)))
  1021.       (if (nth 2 data) (set-extent-property ext 'help-echo (nth 2 data))))
  1022.      ((eq (car data) 'w3form)
  1023.       (let* ((args (nth 1 data))
  1024.          (mesg
  1025.           (cond
  1026.            ((string= "SUBMIT" (nth 2 data))
  1027.         (format "Submit form to %s" (cdr-safe (assoc "action" args))))
  1028.            ((string= "RESET" (nth 2 data))
  1029.         "Reset form contents")
  1030.            (t
  1031.         (format "Form entry (name=%s, type=%s)" (nth 3 data)
  1032.             (if (equal "" (nth 2 data))
  1033.                 "text"
  1034.               (downcase (nth 2 data))))))))
  1035.     (set-extent-property ext 'help-echo mesg))))
  1036.     ext))
  1037.  
  1038. (defun w3-follow-mouse-other-frame (e)
  1039.   "Function suitable to being bound to a mouse key.  Follows the link under
  1040. the mouse click, opening it in another frame."
  1041.   (interactive "e")
  1042.   (mouse-set-point e)
  1043.   (w3-follow-link-other-frame))
  1044.  
  1045. (defun w3-follow-mouse (e)
  1046.   (interactive "e")
  1047.   (mouse-set-point e)
  1048.   (w3-follow-link))
  1049.  
  1050. (defun w3-follow-inlined-image-mouse (e)
  1051.   "Follow an inlined image from the mouse"
  1052.   (interactive "e")
  1053.   (mouse-set-point e)
  1054.   (w3-follow-inlined-image))
  1055.  
  1056. (defun w3-follow-inlined-image ()
  1057.   "Follow an inlined image, regardless of whether it is a hyperlink or not."
  1058.   (interactive)
  1059.   (let ((grph (extent-at (point) (current-buffer) 'w3graphic)))
  1060.     (cond
  1061.      (grph (url-maybe-relative (nth 0 (extent-property grph 'w3graphic))))
  1062.      (t (message "No inlined image at point.")))))
  1063.  
  1064. (define-key w3-mode-map 'button2 'w3-follow-mouse)
  1065. (define-key w3-mode-map 'button3 'w3-popup-menu)
  1066. (define-key w3-mode-map '(control button2) 'w3-follow-inlined-image-mouse)
  1067. (define-key w3-mode-map '(shift button2) 'w3-follow-mouse-other-frame)
  1068.  
  1069. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1070. ;;; Functions to build menus of urls
  1071. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1072. (defun w3-toplevel-menu-exists-p (name)
  1073.   "Search for a top level menu called NAME.  Return non-nil iff it exists"
  1074.   (assoc name current-menubar))
  1075.  
  1076. (defun w3-build-xemacs-menu ()
  1077.   "Build xemacs menus from w3-links-list"
  1078.   (if current-menubar
  1079.       (let* ((hot w3-hotlist)
  1080.          (hot-menu nil))
  1081.     (or current-menubar
  1082.         (set-menubar default-menubar))
  1083.     (setq w3-links-menu nil)
  1084.     (map-extents 'w3-build-links-helper)
  1085.     (setq w3-links-menu (cons "Links" w3-links-menu))
  1086.     (while hot
  1087.       (setq hot-menu
  1088.         (cons (vector (car (car hot))
  1089.                   (list 'url-maybe-relative (car (cdr (car hot))))
  1090.                   t) hot-menu))
  1091.       (setq hot (cdr hot)))
  1092.     (setq hot-menu (cons "Hotlist" hot-menu))
  1093.     (set-buffer-menubar (copy-tree w3-menu t))
  1094.     (if (cdr hot-menu)
  1095.         (add-submenu '("Hotlist")
  1096.              (cons "Hotlist"
  1097.                    (w3-breakup-menu (cdr hot-menu)
  1098.                         w3-max-menu-length))))
  1099.     (if (cdr w3-links-menu)
  1100.         (add-submenu '("Go")
  1101.              (cons "Links"
  1102.                    (w3-breakup-menu (cdr w3-links-menu)
  1103.                         w3-max-menu-length)))))))
  1104.  
  1105. (defun w3-popup-menu (e)
  1106.   "Pop up a menu of common w3 commands"
  1107.   (interactive "e")
  1108.   (mouse-set-point e)
  1109.   (let* ((ext (w3-zone-at (point)))
  1110.      (dat (and ext (w3-zone-data ext)))
  1111.      url)
  1112.     (if (event-glyph-extent e)
  1113.     (setq ext (event-glyph-extent e)
  1114.           dat (and ext (extent-property ext 'w3graphic))
  1115.           dat (and dat (list 'w3graphic dat))))
  1116.     (cond
  1117.      ((eq (car dat) 'w3)        ; hyperlink
  1118.       (setq url (nth 2 dat))
  1119.       (popup-menu (cons "Hyperlink"
  1120.             (mapcar
  1121.              (function
  1122.               (lambda (x) (vector (car x) (list (cdr x) url) t)))
  1123.              w3-hyperlink-menu))))
  1124.      ((or (eq (car dat) 'w3graphic)
  1125.       (eq (car dat) 'w3delayed))
  1126.       (setq url (if (listp (nth 1 dat))
  1127.             (car (nth 1 dat))
  1128.           (nth 1 dat)))
  1129.       (popup-menu (cons "Image"
  1130.             (mapcar
  1131.              (function
  1132.               (lambda (x) (vector (car x) (list (cdr x) url) t)))
  1133.              w3-graphlink-menu))))
  1134.      (t (popup-menu w3-popup-menu)))))
  1135.  
  1136. (defun w3-x-popup-dialog (pos descr)
  1137.   "My hacked up function to do a blocking popup menu..."
  1138.   (let ((echo-keystrokes 0)
  1139.     event dialog)
  1140.     (setq dialog (cons (car descr) dialog)
  1141.       descr (cdr descr))
  1142.     (while descr
  1143.       (setq dialog (nconc dialog
  1144.               (list (vector (car descr)
  1145.                     (list (car descr)) t)))
  1146.         descr (cdr descr)))
  1147.     (popup-dialog-box dialog)
  1148.     (catch 'dialog-done
  1149.       (while t
  1150.     (setq event (next-command-event event))
  1151.     (cond
  1152.      ((and (misc-user-event-p event)
  1153.            (stringp (car-safe (event-object event))))
  1154.       (throw 'dialog-done (car-safe (event-object event))))
  1155.      ((and (misc-user-event-p event)
  1156.            (or (eq (event-object event) 'abort)
  1157.            (eq (event-object event) 'menu-no-selection-hook)))
  1158.       (signal 'quit nil))
  1159.      ((button-release-event-p event) nil)
  1160.      (t
  1161.       (beep)
  1162.       (message "Please make a choice from the dialog")))))))
  1163.       
  1164. (defun w3-x-popup-menu (pos menudesc)
  1165.   "If last command was a mouse command use a popup-menu, otherwise do a
  1166. completing read"
  1167.   (if (or (button-press-event-p last-command-event)
  1168.       (button-release-event-p last-command-event)
  1169.       (misc-user-event-p last-command-event))
  1170.       (w3-x-really-popup-menu pos menudesc)
  1171.     (completing-read "Please choose: " (cdr (cdr (car (cdr menudesc))))
  1172.              nil t)))
  1173.  
  1174. (defun w3-x-really-popup-menu (pos menudesc)
  1175.   "My hacked up function to do a blocking popup menu..."
  1176.   (let ((echo-keystrokes 0)
  1177.     event menu)
  1178.     (setq menudesc (cdr (car (cdr menudesc)))) ; remove the title
  1179.     (while menudesc
  1180.       (setq menu (cons (vector (car (car menudesc))
  1181.                    (list (car (car menudesc))) t) menu)
  1182.         menudesc (cdr menudesc)))
  1183.     (setq menu (cons "WWW" menu))
  1184.     (popup-menu menu)
  1185.     (catch 'popup-done
  1186.       (while t
  1187.     (setq event (next-command-event event))
  1188.     (cond ((and (misc-user-event-p event) (stringp (car-safe
  1189.                            (event-object event))))
  1190.            (throw 'popup-done (event-object event)))
  1191.           ((and (misc-user-event-p event)
  1192.             (or (eq (event-object event) 'abort)
  1193.             (eq (event-object event) 'menu-no-selection-hook)))
  1194.            (signal 'quit nil))
  1195.           ((not (popup-menu-up-p))
  1196.            (throw 'popup-done nil))
  1197.           ((button-release-event-p event);; don't beep twice
  1198.            nil)
  1199.           (t
  1200.            (beep)
  1201.            (message "please make a choice from the menu.")))))))
  1202.  
  1203. (defun w3-setup-version-specifics ()
  1204.   "Set up routine for XEmacs 19.12 or later"
  1205.   (if (not w3-toolbar-icon-directory)
  1206.       (setq w3-toolbar-icon-directory
  1207.         (file-name-as-directory
  1208.          (expand-file-name "w3" data-directory))))
  1209.   (cond
  1210.    ((>= emacs-minor-version 12)
  1211.     (if (not (file-exists-p w3-toolbar-icon-directory))
  1212.     (w3-warn 'files "Toolbar directory does not exist.")
  1213.       (if (fboundp 'toolbar-make-button-list)
  1214.       (w3-toolbar-make-buttons))))
  1215.    ((>= emacs-minor-version 10)
  1216.     (w3-downgrade-menus)
  1217.     (fset 'w3-insert 'insert))
  1218.    (t
  1219.     ;; Really old version - this will get filled in when
  1220.     ;; the WinEmacs stuff is merged in here.
  1221.     ))
  1222.  
  1223.   ;; Add our menus, but make sure that we do it to the global menubar
  1224.   ;; not the current one, which could be anything, but usually GNUS or
  1225.   ;; VM if not the default.
  1226.   (save-excursion
  1227.     (set-buffer (get-buffer-create "*scratch*"))    
  1228.     (if current-menubar
  1229.     (progn
  1230.       (add-submenu '("Options") (cons "WWW" (cdr
  1231.                          (assoc "Options" w3-menu)))
  1232.                "Save Options")
  1233.       (add-submenu '("Help") (cons "WWW" (cdr (assoc "Help" w3-menu)))))))
  1234.  
  1235.   ;; Check for whether they have giftopnm or giftoppm
  1236.   (let ((exists (w3-executable-exists-in-path "giftopnm"))
  1237.     (cell (assoc "image/gif" w3-graphic-converter-alist)))
  1238.     (if (w3-executable-exists-in-path "giftopnm")
  1239.     (message "Found giftopnm")
  1240.       (message "No giftopnm, defaulting to giftoppm")
  1241.       (aset (cdr cell) 6 ?p)))
  1242.  
  1243.   ;; Add the local etc directory to the icon search path
  1244.   (if (boundp 'data-directory)
  1245.       (let ((maybe-dir (file-name-as-directory
  1246.             (expand-file-name "w3" data-directory))))
  1247.     (if (file-directory-p maybe-dir)
  1248.         (setq w3-icon-directory-list (cons (concat "file:" maybe-dir)
  1249.                            w3-icon-directory-list)))))
  1250.   )
  1251.  
  1252. (defun w3-store-in-x-clipboard (str)
  1253.   "Store string STR into the clipboard in X"
  1254.   (if (or (<= emacs-minor-version 11)
  1255.       (not (eq (device-type) 'tty)))
  1256.       (progn
  1257.     (x-own-selection str 'PRIMARY)
  1258.     (x-selection-owner-p 'PRIMARY))
  1259.     (message "No cut buffer on a tty!")))
  1260.  
  1261. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1262. ;;; Graphics functions
  1263. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1264.  
  1265. (defun w3-maybe-load-images ()
  1266.   (let ((tmp w3-delayed-images)        ; All images
  1267.     (ldd nil)            ; Loaded ones
  1268.     (rest nil)            ;
  1269.     (buffer-read-only nil)
  1270.     )
  1271.     (or (fboundp 'w3-insert-graphic)
  1272.     (error "Cannot do images..."))
  1273.     (while tmp
  1274.       (if (assoc (car (car (car tmp))) w3-graphics-list)
  1275.       (progn
  1276.         (apply 'w3-insert-graphic (car tmp))
  1277.         (setq ldd (cons (car (car (car tmp))) ldd)
  1278.           w3-graphics-list (delq (car tmp) w3-graphics-list))))
  1279.       (setq tmp (cdr tmp)))
  1280.     (map-extents
  1281.      (function
  1282.       (lambda (ext maparg)
  1283.     (if (extent-property ext 'w3delayed)
  1284.         (setq rest (cons ext rest)))
  1285.     nil)))
  1286.     (while rest
  1287.       (if (member (car (car (extent-property (car rest) 'w3delayed))) ldd)
  1288.       (progn
  1289.         (delete-region (extent-start-position (car rest))
  1290.                (extent-end-position (car rest)))
  1291.         (delete-extent (car rest))))
  1292.       (setq rest (cdr rest)))))
  1293.  
  1294. (defun w3-load-delayed-images ()
  1295.   "Load inlined images that were delayed, if necessary."
  1296.   (interactive)
  1297.   (if (eq (device-type) 'tty)
  1298.       nil
  1299.     (let ((buffer-read-only nil) rest)
  1300.       (map-extents
  1301.        (function
  1302.     (lambda (ext maparg)
  1303.       (if (extent-property ext 'w3delayed)
  1304.           (setq rest (cons ext rest)))
  1305.       nil)))
  1306.       (while rest
  1307.     (delete-region (extent-start-position (car rest))
  1308.                (extent-end-position (car rest)))
  1309.     (delete-extent (car rest))
  1310.     (setq rest (cdr rest)))
  1311.       (mapcar (function
  1312.            (lambda (data)
  1313.          (save-excursion
  1314.            (apply 'w3-insert-graphic data))))
  1315.           w3-delayed-images)
  1316.       (setq w3-delayed-images nil))
  1317.     (set-buffer-modified-p nil)))
  1318.  
  1319. (defun w3-load-delayed-mpegs ()
  1320.   "Load all delayed mpeg movies for this buffer"
  1321.   (interactive)
  1322.   (let ((buffer-read-only nil) rest)
  1323.     (map-extents
  1324.      (function
  1325.       (lambda (ext maparg)
  1326.     (if (extent-property ext 'w3mpeg)
  1327.         (setq rest (cons ext rest)))
  1328.     nil)))
  1329.     (while rest
  1330.       (delete-region (extent-start-position (car rest))
  1331.              (extent-end-position (car rest)))
  1332.       (delete-extent (car rest))
  1333.       (setq rest (cdr rest)))
  1334.     (mapcar (function (lambda (data)
  1335.             (apply 'w3-insert-mpeg data)))
  1336.         w3-delayed-movies)
  1337.     (setq w3-delayed-movies nil)))
  1338.  
  1339. (defun w3-insert-mpeg (src pt &optional width height)
  1340.   "Insert an mpeg file SRC at point PT"
  1341.   (let* ((ext (make-extent pt pt))
  1342.      (win (make-x-window-glyph (or width w3-mpeg-size)
  1343.                    (or height w3-mpeg-size)))
  1344.      (fname (url-generate-unique-filename "%s.mpg"))
  1345.      (w3-mpeg-args (append w3-mpeg-args
  1346.                    (list "-window" (int-to-string
  1347.                         (x-window-glyph-xid win))
  1348.                      fname)))
  1349.      (url-working-buffer (url-generate-new-buffer-name " *embed*")))
  1350.     (save-excursion
  1351.       (set-buffer (get-buffer-create url-working-buffer))
  1352.       (setq url-be-asynchronous nil)
  1353.       (url-retrieve src)
  1354.       (write-region (point-min) (point-max) fname nil 5)
  1355.       (kill-buffer (current-buffer)))
  1356.     (set-extent-begin-glyph ext win)
  1357.     (set-extent-property ext 'w3-mpeg
  1358.              (cons (apply 'start-process src nil
  1359.                       w3-mpeg-program w3-mpeg-args)
  1360.                    win))))
  1361.  
  1362. (defun w3-mpeg-kill-processes (&optional buffer)
  1363.   "Kill all mpeg_play processes associated with this buffer"
  1364.   (interactive)
  1365.   (map-extents
  1366.    (function
  1367.     (lambda (ext maparg)
  1368.       (let ((data (extent-property ext 'w3-mpeg)))
  1369.     (if (not data)
  1370.         nil
  1371.       (delete-process (car data))
  1372.       (delete-extent ext)
  1373.       nil))))))        
  1374.  
  1375. (defun w3-load-single-delayed-mpeg (st nd src pt)
  1376.   "Load a single delayed mpeg"
  1377.   (let ((buffer-read-only nil))
  1378.     (delete-region st nd)
  1379.     (w3-insert-mpeg src st)))
  1380.  
  1381. (defun w3-load-single-delayed-graphic (st nd src pt align alt)
  1382.   "Load a single delayed image."
  1383.   (let ((buffer-read-only nil))
  1384.     (delete-region st nd)
  1385.     (w3-insert-graphic src pt align alt)))  
  1386.  
  1387. (defvar w3-mode-xemacs-data-map (make-sparse-keymap))
  1388. (defvar w3-mode-xemacs-event-map (make-sparse-keymap))
  1389. (set-keymap-name w3-mode-xemacs-data-map 'annotation-local-map)
  1390. (set-keymap-name w3-mode-xemacs-event-map 'annotation-local-map)
  1391.  
  1392. (cond
  1393.  ((fboundp 'glyph-width) (fset 'w3-pixmap-width 'glyph-width))
  1394.  ((fboundp 'pixmap-width) (fset 'w3-pixmap-width 'pixmap-width))
  1395.  (t (fset 'w3-pixmap-width 'identity)))
  1396.  
  1397. (define-key w3-mode-xemacs-data-map
  1398.   'button2 'annotation-activate-function-default)
  1399. (define-key w3-mode-xemacs-event-map
  1400.   'button2 'annotation-activate-function-with-event)
  1401. (define-key w3-mode-xemacs-data-map 'button3 'w3-popup-menu)
  1402. (define-key w3-mode-xemacs-event-map 'button3 'w3-popup-menu)
  1403.  
  1404. (defun w3-right-spaces (glyph)
  1405.   "Return the number of spaces to insert in order to right-justify
  1406. the given glyph (may be a string or a pixmap).
  1407. Assume spaces are as wide as avg-pixwidth.  
  1408. Won't be quite right for proportional fonts, but it's the best we can do."
  1409.   (let* ((avg-pixwidth     (round (/ (frame-pixel-width) (frame-width))))
  1410.      (fill-area-width  (* avg-pixwidth (- fill-column left-margin)))
  1411.      (glyph-pixwidth   (cond ((stringp glyph) 
  1412.                   (* avg-pixwidth (length glyph)))
  1413.                  ((glyphp glyph)
  1414.                   (glyph-width glyph))
  1415.                  (t
  1416.                   (error "startup-center-spaces: bad arg")))))
  1417.     (+ left-margin
  1418.        (round (/ (- fill-area-width glyph-pixwidth) avg-pixwidth)))))
  1419.   
  1420. (defun w3-center-spaces (glyph)
  1421.   "Return the number of spaces to insert in order to center
  1422. the given glyph (may be a string or a pixmap).
  1423. Assume spaces are as wide as avg-pixwidth.  
  1424. Won't be quite right for proportional fonts, but it's the best we can do."
  1425.   (let* ((avg-pixwidth     (round (/ (frame-pixel-width) (frame-width))))
  1426.      (fill-area-width  (* avg-pixwidth (- fill-column left-margin)))
  1427.      (glyph-pixwidth   (cond ((stringp glyph) 
  1428.                   (* avg-pixwidth (length glyph)))
  1429.                  ((glyphp glyph)
  1430.                   (glyph-width glyph))
  1431.                  (t
  1432.                   (error "startup-center-spaces: bad arg")))))
  1433.     (+ left-margin
  1434.        (round (/ (/ (- fill-area-width glyph-pixwidth) 2) avg-pixwidth)))))
  1435.  
  1436. (defun w3-make-pixmap (fname alt)
  1437.   (make-glyph (list (cons 'x fname)
  1438.             (cons 'tty alt))))
  1439.  
  1440. (defun w3-insert-graphic (name pt align alt &optional force)
  1441.   "Insert the graphic pointed to by the URL NAME, at buffer position POINT,
  1442. with alignment specified by ALIGN (one of 'center 'top or 'bottom).  If the
  1443. conversion of the picture fails for any reason, use ALT as the alternative
  1444. text.  If the reading of the pixmap is successful, the url and a pointer to
  1445. the pixmap are stored in w3-graphics-list for possible re-use later."
  1446.   (let ((bit nil)
  1447.     (add-to-list nil)
  1448.     (buffer-read-only nil)
  1449.     (url-request-method "GET")
  1450.     (url-be-asynchronous nil)
  1451.     (url-request-data nil)
  1452.     (url-request-extra-headers nil)
  1453.     (url-source t)
  1454.     (url-mime-accept-string nil)
  1455.     (err nil)
  1456.     (lnk (cdr name))
  1457.     (fname (url-generate-unique-filename)))
  1458.     (setq name (car name)
  1459.       url-mime-accept-string
  1460.       (substring
  1461.        (mapconcat
  1462.         (function
  1463.          (lambda (x)
  1464.            (if x (concat (car x) ",") ""))) w3-allowed-image-types "")
  1465.        0 -1))
  1466.     (if (<= pt 0)
  1467.     (setq pt 1))
  1468.     (save-excursion
  1469.       (let ((w3-working-buffer " *W3GRAPH*")
  1470.         (url-working-buffer " *W3GRAPH*")
  1471.         (attribs (or (assoc name w3-graphics-list)
  1472.              (url-file-attributes name))))
  1473.     (set-buffer (get-buffer-create url-working-buffer))
  1474.     (setq url-be-asynchronous nil)
  1475.     (cond
  1476.      ((assoc name w3-graphics-list)
  1477.       (message "Reusing image...")
  1478.       (setq bit (cdr (assoc name w3-graphics-list))))
  1479.      ((and (not force)
  1480.            (not (assoc (nth 8 attribs) w3-allowed-image-types)))
  1481.       (url-lazy-message "Skipping image %s [%s]" 
  1482.                 (url-basepath name t) (nth 8 attribs))
  1483.       (let ((anno (make-annotation alt pt 'text)))
  1484.         (set-extent-property anno 'w3graphic name)
  1485.         (set-annotation-data anno
  1486.                  (list (cons name lnk) pt align alt t))
  1487.         (set-extent-property anno 'keymap w3-mode-xemacs-data-map)
  1488.         (set-extent-property anno 'help-echo (cond
  1489.                           ((listp lnk) (car lnk))
  1490.                           ((stringp lnk) lnk)
  1491.                           (t nil)))
  1492.         (set-annotation-action anno 'w3-annotation-action-2)))
  1493.      ((and (not force)
  1494.            (numberp w3-image-size-restriction)
  1495.            (> 0 (nth 7 attribs))
  1496.            (> (nth 7 attribs) w3-image-size-restriction))
  1497.       (url-lazy-message "Skipping image %s [%s bytes]" 
  1498.                 (url-basepath name t) (nth 7 attribs))
  1499.       (let ((anno (make-annotation alt pt 'text)))
  1500.         (set-extent-property anno 'w3graphic name)
  1501.         (set-extent-property anno 'detachable nil)
  1502.         (set-annotation-data anno
  1503.                  (list (cons name lnk) pt align alt t))
  1504.         (set-extent-property anno 'help-echo (cond
  1505.                           ((listp lnk) (car lnk))
  1506.                           ((stringp lnk) lnk)
  1507.                           (t nil)))
  1508.         (set-extent-property anno 'keymap w3-mode-xemacs-data-map)
  1509.         (set-annotation-action anno 'w3-annotation-action-2)))
  1510.      (t
  1511.       (setq add-to-list t
  1512.         err t)
  1513.       (url-retrieve name)
  1514.       (url-uncompress)
  1515.       (w3-convert-graphic-to-useable-format url-working-buffer
  1516.                         fname
  1517.                         (not (featurep 'xpm)))
  1518.       (message "Reading image %s..." url-current-file)
  1519.       (if (equal 0 (nth 7 (file-attributes fname)))
  1520.           (save-excursion
  1521.         (set-buffer url-working-buffer)
  1522.         (let ((x (buffer-string)))
  1523.           (w3-warn 'image
  1524.                (concat "Reading of image " name " failed!\n"
  1525.                    x))))
  1526.         (condition-case ()
  1527.         (setq bit (w3-make-pixmap fname alt))
  1528.           (error (save-excursion
  1529.                (set-buffer url-working-buffer)
  1530.                (let ((x (buffer-string)))
  1531.              (w3-warn 'image
  1532.                   (concat "Reading of image " name " failed!\n"
  1533.                       x)))))))
  1534.       (condition-case ()
  1535.           (delete-file fname)
  1536.         (error nil))))))
  1537.     (and add-to-list
  1538.      (setq w3-graphics-list (cons (cons name bit) w3-graphics-list)))
  1539.     (cond 
  1540.      (bit
  1541.       (if (fboundp 'set-glyph-baseline)
  1542.       (set-glyph-baseline bit (cond
  1543.                    ((eq align 'top) 0)
  1544.                    ((memq align '(center middle)) 50)
  1545.                    ((eq align 'bottom) 100)
  1546.                    (t 50))))
  1547.       (if (= (or (char-after pt) 0) ?\t) (setq pt (max 1 (1- pt))))
  1548.       (if (>= (w3-pixmap-width bit) (/ (frame-pixel-width) 2))
  1549.       (save-excursion
  1550.         (goto-char pt)
  1551.         (insert "\n\n")
  1552.         (setq pt (1+ pt))))
  1553.       (let ((anno (make-annotation bit pt 'text nil t)))
  1554.     (set-extent-property anno 'w3graphic name)
  1555.     (set-extent-property anno 'keymap w3-mode-xemacs-data-map)
  1556.     (set-annotation-data anno lnk)
  1557.     (set-extent-property anno 'help-echo (cond
  1558.                           ((listp lnk) (car lnk))
  1559.                           ((stringp lnk) lnk)
  1560.                           (t nil)))
  1561.     (set-extent-property anno 'keymap w3-mode-xemacs-event-map)
  1562.     (set-annotation-action anno 'w3-annotation-action-3)))
  1563.      (err
  1564.       (let ((anno (make-annotation alt pt 'text)))
  1565.     (set-extent-property anno 'w3graphic name)
  1566.     (set-extent-property anno 'keymap w3-mode-xemacs-data-map)
  1567.     (set-annotation-data anno (cons name lnk))
  1568.     (set-extent-property anno 'help-echo (cond
  1569.                           ((listp lnk) (car lnk))
  1570.                           ((stringp lnk) lnk)
  1571.                           (t nil)))
  1572.     (set-extent-property anno 'keymap w3-mode-xemacs-data-map)
  1573.     (set-annotation-action anno 'w3-annotation-action-1)))
  1574.      (t nil))
  1575.     bit))
  1576.  
  1577. (defun w3-annotation-action-1 (data)
  1578.   "Annotation function that passes a failed image off to an external viewer"
  1579.   (w3-fetch (car data)))
  1580.  
  1581. (defun w3-annotation-action-2 (data)
  1582.   "Annotation function that tries to load 1 delayed image."
  1583.   (set-buffer (extent-buffer extent))
  1584.   (delete-annotation extent)
  1585.   (apply 'w3-insert-graphic data))
  1586.  
  1587. (defun w3-annotation-action-3 (data event)
  1588.   "Annotation function that tries send off an imagemap click"
  1589.   (let* ((url (car data))
  1590.      (x (and (fboundp 'event-glyph-x-pixel) (event-glyph-x-pixel event)))
  1591.      (y (and (fboundp 'event-glyph-y-pixel) (event-glyph-y-pixel event)))
  1592.      )
  1593.     (cond
  1594.      ((and (eq (cdr data) 'ismap) (stringp url))
  1595.       (if (and x y)
  1596.       (w3-fetch (concat url "?" (int-to-string x) "," (int-to-string y)))
  1597.     (error "Imagemaps not implemented in this version of emacs.")))
  1598.      ((stringp url) (w3-fetch url))
  1599.      (t nil))))
  1600.  
  1601. (defun w3-mode-version-specifics ()
  1602.   "XEmacs specific stuff for w3-mode"
  1603.   (if current-menubar
  1604.       (if (not (fboundp 'set-specifier))
  1605.       (progn
  1606.         (w3-build-xemacs-menu)
  1607.         (let ((formats
  1608.            (cons "Image Types"
  1609.              (mapcar
  1610.               (function
  1611.                (lambda (data)
  1612.                  (let ((typ (car data)))
  1613.                    (vector typ
  1614.                        (list 'w3-ins-or-del-graphic typ)
  1615.                        ':style 'toggle
  1616.                        ':selected
  1617.                        (list 'assoc typ
  1618.                          'w3-allowed-image-types)))))
  1619.               w3-graphic-converter-alist))))
  1620.           (add-hook 'activate-menubar-hook 'w3-sensitize-menu)
  1621.           (add-submenu '("Options") formats "Flush Image Cache")))
  1622.     (set-buffer-menubar w3-menu)))
  1623.   (cond
  1624.    ((not w3-track-mouse)
  1625.     nil)
  1626.    ((or (not (boundp 'inhibit-help-echo))
  1627.     inhibit-help-echo)
  1628.     (setq mode-motion-hook 'w3-mouse-handler))
  1629.    (t nil))
  1630.   (if (eq (device-type) 'tty)
  1631.       nil
  1632.     (if (fboundp 'set-specifier)
  1633.     (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
  1634.       (if toolbar
  1635.           (set-specifier toolbar (cons (current-buffer) w3-toolbar)))))
  1636.     (if (and (boundp 'toolbar-buttons-captioned-p)
  1637.          (eq w3-toolbar-type 'both))
  1638.     (set-specifier toolbar-buttons-captioned-p
  1639.                (cons (current-buffer) t))))
  1640.   (setq mode-popup-menu w3-popup-menu))
  1641.  
  1642. (defun w3-map-links (function &optional buffer from to maparg)
  1643.   "Map FUNCTION over the hypertext links which overlap region in BUFFER,
  1644. starting at FROM and ending at TO.  FUNCTION is called with the arguments
  1645. linkdata, START, END, and MAPARG.
  1646. The arguments FROM, TO, MAPARG, and BUFFER default to the beginning of
  1647. BUFFER, the end of BUFFER, nil, and (current-buffer), respectively."
  1648.   (map-extents (function (lambda (x y)
  1649.                (if (extent-property x 'w3)
  1650.                    (funcall function (w3-zone-data x)
  1651.                     (extent-start-position x)
  1652.                     (extent-end-position x)
  1653.                     y))
  1654.                nil)) buffer from to maparg))
  1655.  
  1656.     
  1657. (provide 'w3-xemacs)
  1658. (provide 'w3-xemac)
  1659.